C**** PACKMS.F4 -- TO PACK TOGETHER MANY MS PROGRAM FILES *****
C LOAD WITH [NEW,LCS] MSSIO.FAI,STUF.FAI
	DIMENSION NAMES(635),JEXT(200),JREC(235),
	1 FIRST(128),V(2000),SECOND(4000),INP(72)
C JREC(235) HAS 34 WDS FREE FOR MISC. INFO
	EQUIVALENCE(JWDS,FIRST(19)),(KREC,JREC(202)),(JEXT,NAMES(201))
	1 ,(JREC,NAMES(401)),(JFLAG,FIRST(128))
	IREC=1
	JREC(1)=6
15	FORMAT(' P(ACK), U(NPACK), R(EAD DIR.FILE), D(IRECTORY)?  '$)
C**************************************************************************
C**** WHEN READING DIR.FILE 1ST 2 LINES AND LAST 2 LINES ARE IGNORED.******
C**************************************************************************
18	TYPE 15
	ACCEPT 1,JWDS,K,L
	IPU=0
	MORE=0
	IFI=0
	IF(JWDS.NE.'R')GO TO 180
C NOW READ A DIRECTORY FILE FOR INPUT 
	IFI=-1
	CALL FILE(NAMES,JEXT,JJ)
	GO TO 142
180	IF(JWDS.EQ.'P')GO TO 2
	INF=-1
	IPU=-1
	IF(JWDS.EQ.'D')	IPU=-IPU
C PACK=0,  UNPACK=-1, DIRECTORY=1
16	FORMAT(' TYPE PACK FILE NAME AND EXT.(DEFAULT EXT=.PAK)  '$)
17	TYPE 16
	ACCEPT 1,INP
	X=' '
	CALL NAMEXT(INP,IPAK,X)
	IF(INP(1).EQ.' ')IPAK=JPAK
	JPAK=IPAK
	IF(X.EQ.' ')X='PAK'
	IF(LOOKX(IPAK,X).EQ.0)GO TO 17
	IF(IPU.GT.0)GO TO 113
1	FORMAT(72A1)
2	IF(IPU.LT.0)GO TO 41
	TYPE 3
	GO TO 42
41	TYPE 40
3	FORMAT(' TYPE FIRST NAME AND EXT.(DEFAULT EXT=.MS)  '$)
40	FORMAT(' TYPE FIRST NAME AND EXT.(DEFAULT EXT=.MS) OR "ALL"  '$)
4	FORMAT(' TYPE LAST NAME OR "ALL" (NO EXT, <CR>=1 FILE ONLY)  '$)
42	ACCEPT 1,INP
	KEXT=' '
	CALL NAMEXT(INP,NAME,KEXT)
	IF(KEXT.EQ.' ')KEXT='MS'
	IF(IPU.LT.0.AND.NAME.EQ.'ALL')GO TO 122
	IF(IPU.LT.0)GO TO 19
	IF(LOOKX(NAME,KEXT).EQ.0)GO TO 2 
19	TYPE 4
	ACCEPT 1,INP
	NAME2=' '
	X2=' '
	CALL NAMEXT(INP,NAME2,X2)
	IF(NAME2.EQ.' ')NAME2=NAME
	IF(X2.EQ.' ')X2=KEXT
	IF(X2.NE.KEXT)GO TO 18
	IF(IPU.LT.0)GO TO 121
	IF(NAME2.EQ.'ALL')NAME2='99999'
12	IF(MORE.LT.0)GO TO 21
142	TYPE 16
	ACCEPT 1,INP
	X=' '
	CALL NAMEXT(INP,IPAK,X)
	IF(X.EQ.' ')X='PAK'
13	IF(LOOKX(IPAK,X).EQ.0)GO TO 10
	TYPE 11
11	FORMAT(' WRITE OVER THAT NAME?  '$)
	ACCEPT 1,INP
	IF(INP(1).NE.'Y')GO TO 12
10	CALL PUTEXT(IPAK,X)
	CALL EXTOUT(NAMES,635)
C COME BACK AND FILL UP THE HEADER LATER.
21	NM=NAME
	MORE=0
20	NMX=NM
	NMZ=NM
	KK=0
6	IF(IFI.EQ.0)GO TO 66
67	KK=KK+1
	IF(KK.GT.JJ)GO TO 2000
	NM=NAMES(KK)
	KEXT=JEXT(KK)
66	IF(LOOKX(NM,KEXT).EQ.0)GO TO 1000
C JUMP IF NOT FOUND
7	CALL GETEXT(NM,KEXT)
	CALL EXTIN(FIRST,128)
	CALL EXTIN(SECOND,JWDS)
	CALL STUFIT(SECOND,JWDS)
C  GO MAKE PACKED VERSION OF DATA
	JFLAG=-999
	CALL EXTOUT(FIRST,128)
	CALL EXTOUT(SECOND,JWDS)
	TYPE 9,NM,KEXT
	NAMES(IREC)=NM
	JEXT(IREC)=KEXT
	KREC=IREC
	IREC=IREC+1
	JREC(IREC)=JREC(IREC-1)+2+(JWDS-1)/128
C SAVE FOR USETI
	IF(IFI.LT.0)GO TO 67
	IF(IREC.LT.201)NAMES(IREC)=0
14	IF(NM.EQ.NAME2.OR.IREC.EQ.200)GO TO 2000
C LIMIT OF 200 FILES AT THIS TIME.
	NM=NM+2
	GO TO 6
1000	NM=NMX+256
C UPDATE 4TH CHAR.  (E.G. AAAAA TO AAABA)
	NMX=NM
	IF(LOOKX(NM,KEXT).LT.0)GO TO 7
	NM=NMZ+32768
C UPDATE 3RD CHAR. (E.G. AAAAA TO AABAA)
	NMX=NM
	NMZ=NM
	IF(LOOKX(NM,KEXT).LT.0)GO TO 7
C NOW ALL DONE.  REBUILD HEADER.
2001	FORMAT(' ADD MORE TO FILE?  '$)
2000	TYPE 2001
	ACCEPT 1,K
	MORE=-1
	IFI=0
	IF(K.EQ.'Y')GO TO 2
	CALL USTO(1)
	CALL EXTOUT(NAMES,635)
	CALL FINEXT
	TYPE 8,IPAK,X,KREC
	CALL EXIT
8	FORMAT(' ***** ALL DONE WRITING ',A5,'.',A3/5XI3,' FILES')
9	FORMAT(1XA5,'.',A3)
122	IPU=4
121	TYPE 111
111	FORMAT(' CHANGE EXTENSION TO -- (<CR>=NO CHANGE)  '$)
112	FORMAT(A3)
	ACCEPT 112,NEXT
	IF(NEXT.NE.' ')KEXT=NEXT
113	CALL GETEXT(IPAK,X)
	CALL EXTIN(NAMES,635)
	IF(IPU.LE.0)GO TO 114
	GO TO(109,2,118,3000)IPU
118	GO TO 18
115	FORMAT(' TYPE NEW NAME AND EXT.  '$)
119	MEXT=' '
	TYPE 115
	ACCEPT 1,INP
	CALL NAMEXT(INP,NAME2,MEXT)
	IF(MEXT.EQ.' ')MEXT=KEXT
	NMX=0
	DO 116 K=1,200
	NN=NAMES(K)
	MM=JEXT(K)
	IF(NAME.EQ.NN.AND.KEXT.EQ.MM)NMX=K
116	IF(NAME2.EQ.NN.AND.MEXT.EQ.MM)GO TO 117
	IF(NMX.NE.0)GO TO 120
	TYPE 102
	CALL EXIT
120	NAMES(NMX)=NAME2
	JEXT(NMX)=MEXT
	CALL EXIT
CCCC GO WRITE NEW FORM OF .PAK FILE	GO TO ????
117	TYPE 11
	ACCEPT 1,JWDS
	IF(JWDS.NE.'Y')GO TO 18
114	NM=NAME
	NN=NM
105	DO 101 K=1,200
101	IF(NAMES(K).EQ.NAME)GO TO 108
	NAME=NM+256
	NM=NAME
	DO 107 K=1,200
107	IF(NAMES(K).EQ.NAME)GO TO 108
	NAME=NN+32768
	NN=NAME
	NM=NN
	DO 177 K=1,200
177	IF(NAMES(K).EQ.NAME)GO TO 108
106	IF(INF.NE.0)TYPE 102
	GO TO 18
102	FORMAT(' FILE NOT FOUND')
108	CALL USTI(JREC(K))
	CALL EXTIN(FIRST,128)
	CALL EXTIN(SECOND,JWDS)
C READ INTO SECOND ARRAY.  IF JFLAG=-999 THEN UNDO PACKED FORMAT
	TYPE 9,NAME,KEXT
	INF=0
104	IF(LOOKX(NAME,KEXT).EQ.0)GO TO 103
C IS FILE ALREADY ON DSK?
	TYPE 11
	ACCEPT 1,K
	IF(K.EQ.'Y')GO TO 103
	TYPE 3   
	ACCEPT 1,INP
	CALL NAMEXT(INP,NAME,KEXT)
	GO TO 104
103	JF=JFLAG
	JFLAG=0
	IF(JF.EQ.-999)CALL UNSTUF(SECOND,V,JWDS)
	CALL PUTEXT(NAME,KEXT)
	CALL EXTOUT(FIRST,128)
	IF(JF.EQ.-999)CALL EXTOUT(V,JWDS)
	IF(JF.NE.-999)CALL EXTOUT(SECOND,JWDS)
C USE SECOND ARRAY FOR OLD FORMAT
	CALL FINEXT
	IF(NAME.EQ.NAME2)CALL EXIT
	NAME=NAME+2
	GO TO 105
3004	FORMAT(3XI3,' FILES'/)
109	TYPE 3004,KREC
	 DO 110 K=1,200
	IF(NAMES(K).EQ.0)GO TO 18
110	TYPE 9,NAMES(K),JEXT(K)
	GO TO 18
3000	DO 3001 K=1,200
	NM=NAMES(K)
	IF(NM.EQ.0)CALL EXIT
	MM=JEXT(K)
	IF(NEXT.NE.' ')MM=NEXT
	CALL EXTIN(FIRST,128)
	CALL EXTIN(SECOND,JWDS)
	TYPE 9,NM,MM
3003	IF(LOOKX(NM,MM).EQ.0)GO TO 3002
	TYPE 11
	ACCEPT 1,L
	IF(L.NE.'Y')GO TO 3001
3002	JF=JFLAG
	JFLAG=0
	IF(JF.EQ.-999)CALL UNSTUF(SECOND,V,JWDS)
	CALL PUTEXT(NM,MM)
	CALL EXTOUT(FIRST,128)
	IF(JF.EQ.-999)CALL EXTOUT(V,JWDS)
	IF(JF.NE.-999)CALL EXTOUT(SECOND,JWDS)
	CALL FINEXT
3001	CONTINUE
	END

	SUBROUTINE NAMEXT(I,NAME,IEXT)
C FINDS NAME.EXT IN A1 STRING
	DIMENSION I(1)

	IF(I(1).NE.-1)GO TO 9
C FIRST PASS UP 'G', 'GM', 'RS', ETC.  (=-1)
	DO 1 K=1,72
1	IF(I(K).EQ.' ')GO TO 2
C NOW PASS BLANKS
2	J=72
	DO 3 J=K+1,72
3	IF(I(J).NE.' ')GO TO 4
C NOW FOUND START OF WORD (UNLESS ALL BLANKS)
4	IF(J.NE.72)GO TO 5
	NAME=' '
	RETURN
9	J=1
5	DO 6 K=J,72
	IF(I(K).EQ.' ')GO TO 7
C JUMP IF NAME ONLY
6	IF(I(K).EQ.'.')GO TO 8
7	CALL PACKX(NAME,I(J))
	RETURN
8	CALL RLOOP(I(61),I(J),K-J)
	CALL PACKX(NAME,I(61))
	CALL PACKX(IEXT,I(K+1))
	END

	SUBROUTINE PACKX(NAM,KNM)
	DIMENSION KNM(5)
	DATA KK/128/,LL/"377777777777/,JJ/"2000000000/
	1 , MM/"774000000000/
	NAM=0
	DO 12 K=5,1,-1
	NAM=NAM .OR. (KNM(K) .AND. MM)
	IF (K.EQ.1)RETURN
17	IF (NAM.GE.0)GO TO 13
	NAM = (( NAM .AND. LL)/KK) .OR. JJ
	GO TO 12
13	NAM = NAM / KK
12	CONTINUE
	RETURN
	END

	SUBROUTINE FILE(N,IEXT,J)
	DIMENSION N(1),IEXT(1)
1	FORMAT(A5,A2,A3)
2	FORMAT(1XA5,A2,A3)
3	FORMAT(' TYPE DIR.FILE NAME  '$)
	TYPE 3
	ACCEPT 1,J
	CALL IFILE(1,J)
 	READ(1,1)J
 	READ(1,1)J
	J=1
4	READ(1,1,END=5)N(J),K,IEXT(J)
	IF(N(J).EQ.' ')GO TO 4
	J=J+1
	GO TO 4
5 	J=J-2
7	DO 8 K=1,J-1
	IF(N(K).LT.N(K+1))GO TO 8
	L=N(K+1)
	N(K+1)=N(K)
	N(K)=L
	L=IEXT(K+1)
	IEXT(K+1)=IEXT(K)
	IEXT(K)=L
	GO TO 7
8	CONTINUE
	L=' '
	DO 9 K=1,J
9	TYPE 2,N(K),L,IEXT(K)
	N(J+1)=0
	END